The Original Shareware 1.1/The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso/16/ticket.zip/TICKET.PAS

Pascal/Delphi Source File | 1986-08-05 | 22KB | 652 lines

program labels;   {Produce similar labels differing only by a number}
const
   hmin = 20;
   hmax = 77;
   vmin = 3;
   vmax = 20;
   tl   = '┌';
   tr   = '┐';
   bl   = '└';
   br   = '┘';
   vl   = '│';
   hl   = '─';
   nchar= '@';
   outdev= 'LST:';
   tab   = 4;
   bksp  = ^H;
   ret   = ^M;
   tabc  = ^I;

{ The following is a partial listing of ScanCodes for the IBM PC using KBDIO
  for TURBO PASCAL:
Key     ScanCode }
f1       =15104;
f2       =15360;
f3       =15616;
f4       =15872;
f5       =16128;
f6       =16384;
f7       =16640;
f8       =16896;
f9       =17408;
f10      =17408;

altf1    =26624;
altf2    =26880;
altf3    =27136;
altf4    =27392;
altf5    =27648;
altf6    =27904;
altf7    =28160;
altf8    =28416;
altf9    =28672;
altf10   =28928;

shftf1   =21504;
shftf2   =21760;
shftf3   =22016;
shftf4   =22272;
shftf5   =22528;
shftf6   =22784;
shftf7   =23040;
shftf8   =23296;
shftf9   =23552;
shftf10  =23808;

ctrlf1   =24064;
ctrlf2   =24320;
ctrlf3   =24576;
ctrlf4   =24832;
ctrlf5   =25088;
ctrlf6   =25344;
ctrlf7   =25600;
ctrlf8   =25856;
ctrlf9   =26112;
ctrlf10  =26368;

Home     =18176;
Up       =18432;
PgUp     =18688;
Left     =19200;
Right    =19712;
Endx     =20224;
Down     =20480;
PgDn     =20736;
Ins      =20992;
Del      =21248;

CtrlHome =30464;
CtrlPgUp =-31744; {negative}
CtrlLft  =29440;
CtrlRgt  =29696;
CtrlEnd  =29952;
CtrlPgDn =30208;

ShftHome =18231;
ShftUp   =18488;
ShftPgUp =18745;
ShftLft  =19252;
ShftRgt  =19766;
ShftEnd  =20273;
ShftDn   =20530;
ShftPgDn =20787;
ShftIns  =21040;
ShftDel  =21294;

gminus   =18989;  {on the numeric pad}
gplus    =20011; {"   "     "     "}

var
   labl:                       array [1..80,1..20] of char; {One label}
   line:                       string[80];                  {One line}
   h,v:                        integer;                     {Hor, ver size}
   i,j,k,l,m,n,x,y:            integer;
   lfile,pfile:                text;
   lfilen,dfilen,nfilen:       string[14];
   choice,c:                   char;
   nacross,ndown,pnum,pagelen: integer;
   lownum,hinum:               real;
   ok,insx:                    boolean;
   single:                     boolean;
   margin:                     integer;

function max(i1,i2:integer): integer;
begin
   if i1>i2 then max := i1 else max := i2;
end;

function min(i1,i2:integer): integer;
begin
   if i1<i2 then min := i1 else min := i2;
end;

procedure getscancode(var scancode: integer);
type
   regpack = record
      ax,bx,cx,dx,bp,si,ds,es,flags: integer;
   end;
var
   recpack: regpack;
   ah,al:   byte;

begin
   with recpack do
      ax := $0000;
   intr($16,recpack);
{
gotoxy(1,1);write(recpack.ax);gotoxy(x,y);
}
   scancode := recpack.ax;
end;

procedure getc(var c:char);
var
   i: integer;
begin
   getscancode(i);
   if lo(i)<>0 then c := chr(lo(i)) else begin write(chr(8)); c := ' ' end;
end;

procedure credits;
begin
   clrscr;
   normvideo;
   write(tl);for i := 1 to 77 do write(hl); write(tr);
   for i := 2 to 20 do begin
      gotoxy(1,i); write(vl);
      gotoxy(79,i); write(vl);
   end;
   gotoxy(1,21); write(bl); for i := 1 to 77 do write(hl); write(br);
   gotoxy(3,3);
   lowvideo;
   write('TICKET - A program to produce numbered tickets or labels of any size.');
   gotoxy(3,5);
   write('This program will produce virtually any type of numbered ticket or label.');
   gotoxy(3,6);
   write('You can use the screen editor to make a ticket that looks the way you want.');
   gotoxy(3,7);
   write('With the print menu you can choose any number across and down on a page.');
   gotoxy(3,8);
   write('The label files are simple ascii files.  Any file not greater than 20');
   gotoxy(3,9);
   write('lines by 78 characters may be used.');
   gotoxy(3,11);
   write('This program is provided by RAXCO SOFTWARE LTD., 18 COWDY ST., KINGSTON,');
   gotoxy(3,12);
   write('ONTARIO, K7K 3V7.                          Mike Draper (613)-549-7502');
   gotoxy(3,15);
   write('See the bottom of the edit screen for key assignments.  The sequential');
   gotoxy(3,16);
   write('numbers are represented by @ signs, one for each digit up to six.  The');
   gotoxy(3,17);
   write('same number may appear up to 8 times on a ticket.  One line is inserted');
   gotoxy(3,18);
   write('between tickets and form feeds are not used.');
   gotoxy(3,25);
   write('Press any key to continue...');
   getc(c);
end;

procedure heading;
begin
   clrscr;
   normvideo;
   write(tl);
   for i := 1 to 77 do write(hl);
   writeln(tr);
   write(vl);
   normvideo;
   write('                   Labels and Tickets with Serial Numbers ');
   gotoxy(79,2);writeln(vl);
   write(bl);
   for i := 1 to 77 do write(hl);
   writeln(br);
   lowvideo;
end;

procedure getfile;
begin
   heading;
   gotoxy(10,5);write('Enter file name of label');
   gotoxy(50,5);write(dfilen);
   gotoxy(65,5);readln(lfilen);
   if length(lfilen)=0 then lfilen := dfilen;
   if length(lfilen)>0 then begin
      if pos('.',lfilen)=0 then lfilen := concat(lfilen,'.LBL');
      assign(lfile,lfilen);
      {$i- set io check off}
      reset(lfile);
      {$i+ set io check back on}
      ok := ioresult=0;
      if not ok then begin
         h := 0; v := 0;
         while (h<hmin) or (h>hmax) do begin
            h := 30;
            gotoxy(1 ,7);write('Enter number of characters across (20-77)');
            gotoxy(60,7);write(h:2);
            gotoxy(65,7);readln(h);
         end;
         while (v<vmin) or (v>vmax) do begin
            v := 5;
            gotoxy(1 ,9);write ('Enter number of lines down  (3-16):');
            gotoxy(60,9);write(v:2);
            gotoxy(65,9);readln(v);
         end;
         for i := 1 to h do
            for j := 1 to v do
               labl[i,j] := ' ';
      end else begin
         v := 0;
         h := 0;
         while not eof(lfile) do begin
            line := '';
            readln(lfile,line);
            v := v+1;
            for i := 1 to length(line) do
               labl[i,v] := line[i];
            h := max(h,length(line));
         end;
         close(lfile);
      end;
   end;
   dfilen := lfilen;
end;

procedure putfile;
begin
   gotoxy(10,23);
   write('Enter filename for saved label. <return> for same :');
   readln(nfilen);
   if length(nfilen)=0 then nfilen := lfilen;
   if pos('.',nfilen)=0 then nfilen := concat(nfilen,'.LBL');
   assign(lfile,nfilen);
   rewrite(lfile);
   for i := 1 to v do begin
      for j := 1 to h do  write(lfile,labl[j,i]);
      writeln(lfile);
   end;
   close(lfile);
end;

procedure gettl;
begin
   x := (80-h) div 2;
   y := (26-v) div 2;
end;

procedure displabl;
begin
   gettl;
   gotoxy(x,y);
   write(tl);
   for i := x+1 to x+h do write(hl);
   write(tr);
   y := y+1;
   gotoxy(x,y);
   for i := 1 to v do begin
      gotoxy(x,y);
      write(vl);
      for j := 1 to h do write(labl[j,i]);
      write(vl);
      y := y+1;
   end;
   gotoxy(x,y);
   write(bl);
   for i := x+1 to x+h do write(hl);
   write(br);
end;

procedure editlabl;
var
   xmax,ymax,xmin,ymin,xoff,yoff,oldx,oldy,xo,yo: integer;
   code: integer;
   hicode,locode: char;

   procedure resetdis;
   begin
      oldx := x; oldy := y;
      displabl;
      gettl;
      x := x+1; y := y+1; xoff := x-1; yoff := y-1;
      xmin :=x;  ymin := y;  xmax := x+h-1; ymax := y+v-1;
      gotoxy(2,2);write('H=',h:2,' V=',v:2);
      x := max(oldx,xmin) ; y := max(oldy,ymin);
      x := min(x,xmax)    ; y := min(y,ymax);
   end;

begin
   resetdis;
   x := xmin; y := ymin;
   gotoxy(1,24);
   write('Ins toggle| Del Char | Home Begin Ln| End line | F1 Long | F3 Wider | Gray -');
   gotoxy(1,25);
   write('SIns Line | SDel Line| Gray + Centre| SEnd Done| F2 Short| F4 Narrow| Cntr All');
   gotoxy(60,2);
   if insx then write('INSERT   ') else write('OVERWRITE');

   repeat
      gotoxy(x,y);
      getscancode(code);
      hicode := chr(hi(code));
      locode := chr(lo(code));
      case code of
         down        : if y<ymax then y := y+1;
         up          : if y>ymin then y := y-1;
         left        : if x>xmin then x := x-1;
         right       : if x<xmax then x := x+1;
         home,shftlft: x := xmin;                          {Begin of line}
         Shfthome    : begin x := xmin; y := ymin end;     {Top left}
         endx,Shftrgt: x := xmax;                          {End of line}
         Shftend     :;                                    {End of edit}
         pgup,shftup : y := ymin;                          {Top line}
         pgdn,shftdn : y := ymax;                          {Bottom line}
         f1          : if v<vmax then begin                {Make longer}
                          v := v+1;
                          for i := 1 to h do labl[i,v] := ' ';
                          resetdis;
                       end;
         f2          : if v>vmin then begin                 {Make shorter}
                          v := v-1;
                          for i := xmin-1 to xmax+1 do begin
                             gotoxy(i,ymin-1);write(' ');
                             gotoxy(i,ymax+1);write(' ');
                          end;
                          resetdis;
                       end;
         f3          : if h<hmax then begin                 {Make wider}
                          h := h+1;
                          for i := 1 to v do labl[h,i] := ' ';
                          resetdis;
                       end;
         f4          : if h>hmin then begin                  {Make narrower}
                          h := h-1;
                          for j := ymin-1 to ymax+1 do begin
                             gotoxy(xmin-1,j);write(' ');
                             gotoxy(xmax+1,j);write(' ');
                          end;
                          resetdis;
                       end;
         shftins      :   begin                                {Insert a line}
                             for i := ymax-1 downto y do
                                for j := xmin to xmax do begin
                                   labl[j-xoff,(i+1)-yoff] := labl[j-xoff,i-yoff];
                                   if i = y then begin
                                      labl[j-xoff,i-yoff] := ' ';
                                   end;
                                end;
                              resetdis;
                          end;
         shftdel      : for i := y to ymax do                {Delete a line}
                           for j := xmin to xmax do begin
                              if i<ymax then
                                 labl[j-xoff,i-yoff] := labl[j-xoff,(i+1)-yoff]
                              else
                                 labl[j-xoff,i-yoff] := ' ';
                              gotoxy(j,i);
                              if i<ymax then
                                 write(labl[j-xoff,i-yoff])
                              else
                                 write(' ');
                           end;

         del         : begin                                 {Delete a char}
                          for i := x-xoff to (xmax-xoff)-1 do begin
                             labl[i,y-yoff] := labl[i+1,y-yoff];
                             gotoxy(i+xoff,y); write(labl[i+1,y-yoff]);
                          end;
                       end;
         ins         : begin                                {Toggle Insert}
                          insx := not insx;
                          gotoxy(60,2);
                          if insx then write('INSERT   ')
                             else write('OVERWRITE');
                       end;
         gminus      : begin                                 {Centre all text}
                         for n := ymin to ymax do begin
                          i := 0;
                          while (labl[i+xmin-xoff,n-yoff]=' ') and (i<=h) do
                             i := i+1;
                          j := 0;
                          while (labl[xmax-xoff-j,n-yoff]=' ') and (j<=h) do
                             j := j+1;
                          if (i+j>1) and (i<>j) then begin
                             while (i-j)>1 do begin
                                for k := 2 to h do
                                   labl[k-1,n-yoff] := labl[k,n-yoff];
                                labl[h,n-yoff] := ' ';
                                i := i-1; j := j+1;
                             end;
                             while (j-i)>0 do begin
                                for k := h-1 downto 1 do
                                   labl[k+1,n-yoff] := labl[k,n-yoff];
                                labl[1,n-yoff] := ' ';
                                i := i+1; j := j-1;
                             end;
                          end;
                        end;
                        resetdis;
                       end;
         gplus       : begin                                 {Centre text}
                          i := 0;
                          while (labl[i+xmin-xoff,y-yoff]=' ') and (i<=h) do
                             i := i+1;
                          j := 0;
                          while (labl[xmax-xoff-j,y-yoff]=' ') and (j<=h) do
                             j := j+1;
                          if (i+j>1) and (i<>j) then begin
                             while (i-j)>1 do begin
                                for k := 2 to h do
                                   labl[k-1,y-yoff] := labl[k,y-yoff];
                                labl[h,y-yoff] := ' ';
                                i := i-1; j := j+1;
                             end;
                             while (j-i)>0 do begin
                                for k := h-1 downto 1 do
                                   labl[k+1,y-yoff] := labl[k,y-yoff];
                                labl[1,y-yoff] := ' ';
                                i := i+1; j := j-1;
                             end;
                          end;
                          resetdis;
                       end
     else begin
        case locode of
           ret     : if y<ymax then begin y:=y+1;x:=xmin;end;
           bksp,^H : if x>xmin then begin
                        x := x-1;
                        for i := x-xoff to (xmax-xoff)-1 do begin
                           labl[i,y-yoff] := labl[i+1,y-yoff];
                           gotoxy(i+xoff,y); write(labl[i+1,y-yoff]);
                        end;
                     end;
           tabc    : if x+tab<=xmax then x := x+tab;
           ' '..'~': begin
                        if insx then begin
                           for i := xmax downto x+1 do begin
                              labl[i-xoff,y-yoff] := labl[(i-1)-xoff,y-yoff];
                              gotoxy(i,y); write(labl[i-xoff,y-yoff]);
                           end;
                        end;
                        gotoxy(x,y);write(locode);
                        labl[x-xoff,y-yoff] := locode;
                        if x<xmax then x := x+1
                     end;
           end;                           {else begin}
        end                           {case}
     end                           {Process char}
  until code=shftend;          {main loop}
end;                        {Procedure}

procedure getoptions;
begin
   gotoxy(20,7 );write('Characters across ',h:2,'  Lines down ',v:2);
   gotoxy(20,9 );write('Low number for numbering');
   gotoxy(50,9 );write(lownum:6:0);
   gotoxy(60,9 );readln(lownum);
   gotoxy(20,11);write('High number to print');
   gotoxy(50,11);write(hinum:6:0);
   gotoxy(60,11);readln(hinum);
   gotoxy(20,13);write('Number of lines on a page');
   gotoxy(50,13);write(pagelen:6);
   gotoxy(60,13);readln(pagelen);
   gotoxy(20,15);write('Number printed across');
   gotoxy(50,15);write(nacross:6);
   gotoxy(60,15);readln(nacross);
   ndown := pagelen div (v+1);
   gotoxy(20,17);write('Number of labels down per page');
   gotoxy(50,17);write(ndown:6);
   gotoxy(60,17);readln(ndown);
   gotoxy(20,19);write('Margin on left characters');
   gotoxy(50,19);write(margin:6);
   gotoxy(60,19);readln(margin);
   gotoxy(20,21);write('Stop after each page?');
   c := ' ';
   while not (c in ['Y','y','T','t','N','n','F','f']) do begin
      gotoxy(60,21);
      getc(c);write(upcase(c));
   end;
   if c in ['T','t','Y','y'] then single := true else single := false;
   gotoxy(20,23);write('OK to continue with printing?');
   c := ' ';
   while not (c in ['Y','y','T','t','N','n','F','f']) do begin
      gotoxy(60,23);
      getc(c);write(upcase(c));
   end;
   if c in ['T','t','Y','y'] then ok := true else ok := false;
end;

procedure printlabel;
var
   cnt:    integer;
   num:    real;
   numpg:  integer;
   ii,jj:  integer;
   mm:     integer;
   nposadj:integer;
   npos:   array[1..8] of integer;
   nlen:   array[1..8] of integer;
   snum:   string[hmax];
   line1:  string[hmax];
   npage:  integer;

   procedure getnumbers;                      {Insert serial numbers}
   begin
      ii := 0; nposadj := 0;
      for jj := 1 to 8 do begin npos[jj] := 0; nlen[jj] := 0; end;
      while pos(nchar,line)>0 do begin
         ii := ii+1;
         npos[ii] := pos(nchar,line);                   {Locate number}
         nlen[ii] := 0;
         m := npos[ii];
         while (npos[ii]>0) and (line[m]=nchar) do begin
            nlen[ii] := nlen[ii]+1;
            m := m+1;
         end;
         delete(line,npos[ii],nlen[ii]);
         npos[ii] := npos[ii]+nposadj;                  {Adjust for prev}
         nposadj := nposadj+nlen[ii];
      end;
    end;

begin
   assign(pfile,outdev);
   rewrite(pfile);
   num := lownum;
   numpg := trunc((hinum-lownum)/(nacross*ndown)+0.999);
   cnt := 0;
   if trunc(hinum-lownum+1)<ndown then ndown := trunc(hinum-lownum+1);

   npage := 1;
   while npage <= numpg do begin                     {Each page}
      for j := 1 to ndown do begin                      {Each Label}
         for k := 1 to v do begin                          {Each line}
            for l := 1 to h do line[l] := labl[l,k];          {Move to LINE}
            line[0] := chr(h);
            getnumbers;
            line1 := line;

            for n := 1 to nacross do begin                     {Labels lines}
               line := line1;
               if num+n-1 <= hinum then begin                     {Ins nums}
                  for jj := 1 to ii do begin
                     if nlen[jj]>0 then begin
                        str(num+n-1:nlen[jj]:0,snum);
                        insert(snum,line,npos[jj]);
                     end;
                  end;
                  if margin>0 then for mm := 1 to margin do write(pfile,' ');
                  write(pfile,line);                 {Write line}
                  gotoxy(65,25);write('P',npage:2,' N',num+n-1:6:0,' L',k:2);

                  if (n<nacross) then write(pfile,':');
                  if num+n-1=hinum then begin               {Short line}
                     writeln(pfile);
                     cnt := cnt+1;
                  end;
               end;
            end;
            if (num+nacross)<=hinum then begin writeln(pfile); cnt := cnt+1; end;
         end;   {Line of labels across}

         if (k=v) and (j<ndown) and (num<hinum) then begin     {skip to bottom}
            if margin>0 then for mm := 1 to margin do write(pfile,' ');
            for n := 1 to nacross*(h+1)-1 do write(pfile,'.');
            writeln(pfile); cnt := cnt+1;
         end;
         num := num+nacross;
      end;      {Row of labels across}

      for n := cnt+1 to pagelen do writeln(pfile);
      cnt := 0;

      if single then begin
         gotoxy( 1,25); write('Insert new page - Anything except Q to continue');
         gotoxy(60,25); getc(c); write(upcase(c));
         gotoxy( 1,25); write('                                                     ');
         if upcase(c)='Q' then npage := 999;
      end;
      npage := npage+1;
   end;         {Page of labels}
end;         {Printlabl}

begin
   single := false;
   insx := false;
   dfilen := 'LABEL.LBL';
   lownum := 1.0;
   hinum := 10.0;
   nacross := 1;
   pagelen := 66;
   ndown :=0;
   margin := 0;
   choice := 'X';
   credits;
   while upcase(choice)<>'Q' do begin
      heading;      {Print heading}
      gotoxy(25,5 );write('E dit label');
      gotoxy(25,7 );write('P rint labels');
      gotoxy(25,9 );write('Q uit program');
      gotoxy(25,15);write('Enter choice :');
      x := 40; y := 15; gotoxy(x,y);
      choice := ' ';
      while not (choice in ['E','P','Q','e','p','q']) do getc(choice);
      write(upcase(c));

      case upcase(choice) of

         'E': begin
                 getfile;                 {Read old label or set up new file}
                 heading;                 {Print heading}
                 editlabl;                {Edit label}
                 putfile;                 {Write out file}
              end;
         'P': begin
                 getfile;                 {Read old label file or new one}
                 getoptions;              {Get printing options}
                 if ok then printlabel;   {Print labels}
              end;
         'Q': ;
      end;    {case}
   end;    {while}
end.    {Program}